open Printf
open Astpp
open Asttypes
open Longident
open Parsetree

(*** Tools ***)

let parenthesis doc = HBox [ Char '(' ; Cut ; doc ; Cut ; Char ')' ]

let void_box = String ""

let is_operator ident =
  assert (ident <> "");
  match ident with
    | "or" | "mod" | "land" | "lor" | "lxor" | "lsl" | "lsr" | "asr" -> true
    | _ ->
	match ident.[0] with
	  | 'A' .. 'Z' | 'a' .. 'z' | '_' -> false
	  | _ -> true

let doc_of_ident ident =
  if is_operator ident then
    if ident.[0] = '*' || ident.[String.length ident - 1] = '*' then
      parenthesis (String (" " ^ ident ^ " "))
    else
      parenthesis (String ident)
  else String ident
  
(*** Asttypes ***)

let rec doc_of_constant constant =
  match constant with
    | Const_int n when n >= 0 -> Int n
    | Const_int n -> HBox [ Char '(' ; Cut ; Int n ; Cut ; Char ')' ]
    | Const_char c -> String (sprintf "%C" c)
    | Const_string s -> String (sprintf "%S" s)
    | Const_float s -> String s
    | Const_int32 n when n >= 0l -> String (sprintf "%ldl" n)
    | Const_int32 n -> String (sprintf "(%ldl)" n)
    | Const_int64 n when n >= 0L -> String (sprintf "%LdL" n)
    | Const_int64 n -> String (sprintf "(%LdL)" n)
    | Const_nativeint n when n >= 0n -> String (sprintf "%ndn" n)
    | Const_nativeint n -> String (sprintf "(%ndn)" n)

and doc_of_rec_flag rec_flag =
  match rec_flag with
    | Nonrecursive | Default -> Space
    | Recursive -> String "rec"

and doc_of_direction_flag direction_flag =
  match direction_flag with
    | Upto -> String "to"
    | Downto -> String "downto"

and doc_of_private_flag private_flag =
  match private_flag with
    | Private -> String "private"
    | Public -> Space

and doc_of_mutable_flag mutable_flag =
  match mutable_flag with
    | Immutable -> Space
    | Mutable -> String "mutable"

and doc_of_virtual_flag virtual_flag =
  match virtual_flag with
    | Virtual -> String "virtual"
    | Concrete -> Space

and doc_of_override_flag override_flag =
  match override_flag with
    | Override -> Char '!'
    | Fresh -> Space

(*** Longident ***)

and doc_of_longident ident =
  match ident with
    | Lident "()" ->
	String "()"

    | Lident "[]" ->
	String "[]"

    | Lident s ->
	doc_of_ident s

    | Ldot (lid, s) ->
	HBox [ doc_of_longident lid ; Cut ; Char '.' ; Cut ; String s ]

    | Lapply (lid1, lid2) ->
	HBox [ doc_of_longident lid1 ; Cut ;
	       parenthesis (doc_of_longident lid2) ]

(*** Parsetree ***)

(* Type expressions for the core language *)

and doc_of_core_type core_type = doc_of_core_type0 core_type

and doc_of_core_type0 core_type =
  doc_of_core_type_desc0 core_type.ptyp_desc
and doc_of_core_type1 core_type =
  doc_of_core_type_desc1 core_type.ptyp_desc
and doc_of_core_type2 core_type =
  doc_of_core_type_desc2 core_type.ptyp_desc

and doc_of_core_type_desc0 core_type_desc =
  match core_type_desc with
    | Ptyp_arrow ("", core_type1, core_type2) ->
	Box (2, [ doc_of_core_type1 core_type1 ; String "->" ;
		  doc_of_core_type0 core_type2 ])

    | Ptyp_arrow (ident, core_type1, core_type2) ->
	Box (2, [ HBox [ String ident ; Cut ; Char ':' ; Cut ;
			 doc_of_core_type1 core_type1 ] ; String "->" ;
		  doc_of_core_type0 core_type2 ])

    | Ptyp_alias (core_type, ident) ->
	Box (0, [ doc_of_core_type0 core_type ; String "as" ; Char '\'' ; Cut ;
		  String ident ])

    | _ ->
	doc_of_core_type_desc1 core_type_desc

and doc_of_core_type_desc1 core_type_desc =
  match core_type_desc with
    | Ptyp_tuple core_types ->
	let rec f core_types =
	  match core_types with
	    | [] -> assert false
	    | [ core_type ] ->
		[ doc_of_core_type2 core_type ]
	    | core_type :: rest ->
		doc_of_core_type2 core_type :: Char '*' :: f rest
	in
	  Box (2, f core_types)

    | _ ->
	doc_of_core_type_desc2 core_type_desc

and doc_of_core_type_desc2 core_type_desc =
  match core_type_desc with
    | Ptyp_any ->
	Char '_'

    | Ptyp_var v ->
	HBox [ Char '\'' ; Cut ; String v ]

    | Ptyp_constr (ident, []) ->
	doc_of_longident ident

    | Ptyp_constr (ident, core_types) ->
	Box (2, [ doc_of_core_types core_types ; doc_of_longident ident ])

    | Ptyp_object core_field_types ->
	let rec f core_field_types =
	  match core_field_types with
	    | [] -> assert false
	    | [ core_field_type ] ->
		[ doc_of_core_field_type core_field_type ; Char '>' ]
	    | core_field_type :: rest ->
		doc_of_core_field_type core_field_type :: Cut :: Char ',' ::
		  f rest
	in
	  Box (0, Char '<' :: f core_field_types)

    | Ptyp_class (ident, [], []) ->
	Box (0, [ Char '#' ; doc_of_longident ident ; Char ']' ])

    | Ptyp_class (ident, core_types, []) ->
	Box (0, [ doc_of_core_types core_types ; Char '#' ;
		  doc_of_longident ident ; Char ']' ])

    | Ptyp_class (ident, [], labels) ->
	Box (0, [ Char '#' ; doc_of_longident ident ; String "[>" ;
		  doc_of_backquote_labels labels "]"])

    | Ptyp_class (ident, core_types, labels) ->
	Box (0, [ doc_of_core_types core_types ; Char '#' ;
		  doc_of_longident ident ; String "[>" ;
		  doc_of_backquote_labels labels "]"])

    | Ptyp_variant (row_fields, closed, labels) ->
	let h row_field =
	  match row_field with
	    | Rtag (ident, _, core_types) ->
		let rec f core_types =
		  match core_types with
		    | [] -> []
		    | core_type :: rest ->
			Char '&' :: doc_of_core_type0 core_type :: f rest
		in
		  begin match core_types with
		    | [] -> HBox [ Char '`' ; Cut ; String ident ]
		    | core_type :: rest ->
			Box (2, HBox [ Char '`' ; Cut ; String ident ;
				       String "of" ] ::
			       doc_of_core_type0 core_type :: f rest)
		  end
	    | Rinherit core_type -> doc_of_core_type0 core_type
	in
	let rec g row_fields =
	  match row_fields with
	    | [] -> assert false
	    | [ row_field ] -> [ h row_field ]
	    | row_field :: rest -> h row_field :: Char '|' :: g rest
	in
	let f row_fields =
	  match row_fields with
	    | [] -> Space
	    | [ row_field ] -> h row_field
	    | _ -> Box (0, g row_fields)
	in
	let content =
	  match (closed, labels) with
	    | (false, Some _) -> assert false
	    | (true, None) -> [ Char '[' ; f row_fields ; Char ']' ]
	    | (false, None) -> [ String "[>" ; f row_fields ; Char ']' ]
	    | (true, Some []) -> [ String "[<" ; f row_fields ; Char ']' ]
	    | (true, Some labels) ->
		[ String "[<" ; f row_fields ; Char '>' ;
		  doc_of_backquote_labels labels "]" ]
	in
	  HBox content

    | Ptyp_poly (strs, core_type) ->
	let g ident = HBox [ Char '\'' ; Cut ; String ident ] in
	let rec f strs =
	  match strs with
	    | [] -> [ doc_of_core_type2 core_type ]
	    | [ ident ] ->
		[ g ident ; Cut ; Char '.' ; doc_of_core_type2 core_type ]
	    | ident :: rest -> g ident :: f rest
	in
	  Box (0, f strs)

    | Ptyp_package pkty ->
	parenthesis (Box (0, [ String "module" ; doc_of_package_type pkty ]))

    | _ ->
	parenthesis (doc_of_core_type_desc0 core_type_desc)

and doc_of_package_type (lid, scts) =
  let g (lid, ct) =
    HBox [ String "type" ; String lid ; Char '=' ; doc_of_core_type ct ]
  in
  let rec f scts =
    match scts with
      | [] -> assert false
      | [ sct ] -> [ g sct ]
      | sct :: rest -> g sct :: String "and" :: f rest
  in
    match scts with
      | [] -> doc_of_longident lid
      | _ -> Box (2, HBox [ doc_of_longident lid ; String "with" ] :: f scts)

and doc_of_core_field_type core_filed_type =
  doc_of_core_field_desc core_filed_type.pfield_desc

and doc_of_core_field_desc core_field_desc =
  match core_field_desc with
    | Pfield (ident, ct) ->
	Box (2, [ HBox [ String ident ; Char ':' ] ; doc_of_core_type ct ])
    | Pfield_var ->
	String ".."

(* Type expressions for the class language *)

and doc_of_class_infos doc_of_expr {
  pci_virt = virt_flag;
  pci_params = (params, _);
  pci_name = name;
  pci_expr = expr;
  pci_variance = variances;
  pci_loc = _;
} =
  [ doc_of_virtual_flag virt_flag ; Space ;
    doc_of_parameters_variances false params variances ;
    String name ; doc_of_expr expr ]

(* Value expressions for the core language *)

and doc_of_pattern pattern = doc_of_pattern0 pattern
and doc_of_pattern0 pattern = doc_of_pattern_desc0 pattern.ppat_desc
and doc_of_pattern1 pattern = doc_of_pattern_desc1 pattern.ppat_desc
and doc_of_pattern2 pattern = doc_of_pattern_desc2 pattern.ppat_desc
and doc_of_pattern3 pattern = doc_of_pattern_desc3 pattern.ppat_desc

and doc_of_pattern_desc0 pattern_desc =
  match pattern_desc with
    | Ppat_or (_, _) ->
	let rec flatten pat =
	  match pat with
	    | Ppat_or (pat1, pat2) ->
		flatten pat1.ppat_desc @ flatten pat2.ppat_desc
	    | _ -> [ pat ]
	in
	let g pat = HBox [ Char '|' ; doc_of_pattern_desc0 pat ] in
	let f pats =
	  match pats with
	    | [] -> assert false
	    | pat :: rest -> doc_of_pattern_desc0 pat :: List.map g rest
	in
	  Box (-2, f (flatten pattern_desc))

    | _ ->
	doc_of_pattern_desc1 pattern_desc

and doc_of_pattern_desc1 pattern_desc =
  match pattern_desc with
    | Ppat_alias (pat, var) ->
	Box (2, [ HBox [ doc_of_pattern2 pat ; String "as" ] ; String var ])

    | _ ->
	doc_of_pattern_desc2 pattern_desc

and doc_of_pattern_desc2 pattern_desc =
  match pattern_desc with
    | Ppat_construct (Lident "[]", None, false) ->
	String "[]"

    | Ppat_construct (Lident "()", None, false) ->
	String "()"

    | Ppat_construct (Lident "true", None, false) ->
	String "true"

    | Ppat_construct (Lident "false", None, false) ->
	String "false"

    | Ppat_construct (Lident "::", _, false) ->
	let rec f pat =
	  match pat with
	    | Ppat_construct (Lident "::",
			      Some { ppat_desc = Ppat_tuple [ p1 ; p2 ] ;
				     ppat_loc = _ }, false) ->
		let (b, tl) = f p2.ppat_desc in
		(b, p1.ppat_desc :: tl)
	    | Ppat_construct (Lident "::",_ , _) -> assert false
	    | Ppat_construct (Lident "[]", None, false) -> (true, [])
	    | _ -> (false, [ pat ])
	in
	let rec g pats =
	  match pats with
	    | [] -> assert false
	    | [ pat ] -> [ doc_of_pattern_desc3 pat ]
	    | pat :: rest ->
		doc_of_pattern_desc3 pat :: String "::" :: g rest
	in
	let rec h pats =
	  match pats with
	    | [] -> [ Char ']' ]
	    | [ pat ] -> [ doc_of_pattern_desc3 pat ; Char ']' ]
	    | pat :: rest ->
		doc_of_pattern_desc3 pat :: Char ';' :: h rest
	in
	let (closed, pats) = f pattern_desc in
	if closed then HOVBox (2, Char '[' :: h pats) else Box (2, g pats)
    | Ppat_construct (ident, None, false) ->
	doc_of_longident ident

    | Ppat_construct (ident, Some pat, false) ->
	Box (2, [ doc_of_longident ident ; doc_of_pattern3 pat ])

    | Ppat_construct (_, _, true) ->
	assert false

    | Ppat_lazy pat ->
	Box (2, [ String "lazy" ; doc_of_pattern3 pat ])

    | Ppat_variant (ident, Some pat) ->
	HBox [ Char '`' ; Cut ; String ident ; doc_of_pattern3 pat ]

    | _ ->
	doc_of_pattern_desc3 pattern_desc

and doc_of_pattern_desc3 pattern_desc =
  match pattern_desc with
    | Ppat_construct (Lident "[]", None, false) ->
	String "[]"

    | Ppat_construct (Lident "()", None, false) ->
	String "()"

    | Ppat_construct (Lident "true", None, false) ->
	String "true"

    | Ppat_construct (Lident "false", None, false) ->
	String "false"

    | Ppat_variant (ident, None) ->
	HBox [ Char '`' ; Cut ; String ident ]

    | Ppat_any ->
	String "_"

    | Ppat_var var ->
	doc_of_ident var

    | Ppat_constant cst ->
	doc_of_constant cst

    | Ppat_tuple pats ->
	let rec f pats =
	  match pats with
	    | [] -> assert false
	    | [ last ] -> [ doc_of_pattern2 last ]
	    | pat :: rest ->
		HBox [ doc_of_pattern2 pat ; Cut ; Char ',' ] :: f rest
	in
	  parenthesis (Box (0, f pats))

    | Ppat_record (ident_pats, closed_flag) ->
	let g ident pat =
	  HBox [ doc_of_longident ident ; Char '=' ; doc_of_pattern pat ]
	in
	let rec f ident_pats =
	  match ident_pats with
	    | [] -> []
	    | [ (ident, pat) ] ->
		[ g ident pat ]
	    | (ident, pat) :: rest ->
		Box (0, [ g ident pat ; Char ';' ]) :: f rest
	in
	let close =
	  if closed_flag = Closed then []
	  else [ Box (0, [ Char ';' ; Char '_' ])]
	in
	  HBox [ Box (2, Char '{' :: f ident_pats @ close) ; Char '}' ]

    | Ppat_array pats ->
	let rec f pats =
	  match pats with
	    | [] -> assert false
	    | [ last ] -> doc_of_pattern last :: [ Cut ; String "|]" ]
	    | pat :: rest -> doc_of_pattern pat :: Cut :: Char ';' :: f rest
	in
	  Box (3, String "[|" :: f pats)

    | Ppat_constraint (pat, core_type) ->
	parenthesis (Box (2, [ HBox [ doc_of_pattern pat ; Char ':' ] ;
			       doc_of_core_type core_type ]))

    | Ppat_type lid ->
	doc_of_longident lid

    | _ ->
	parenthesis (doc_of_pattern_desc0 pattern_desc)

and doc_of_expression expression = doc_of_expression0 expression
and doc_of_expression0 expression = doc_of_expression_desc0 expression.pexp_desc
and doc_of_expression1 expression = doc_of_expression_desc1 expression.pexp_desc
and doc_of_expression2 expression = doc_of_expression_desc2 expression.pexp_desc
and doc_of_expression3 expression = doc_of_expression_desc3 expression.pexp_desc
and doc_of_expression4 expression = doc_of_expression_desc4 expression.pexp_desc
and doc_of_expression5 expression = doc_of_expression_desc5 expression.pexp_desc
and doc_of_expression6 expression = doc_of_expression_desc6 expression.pexp_desc
and doc_of_expression7 expression = doc_of_expression_desc7 expression.pexp_desc
and doc_of_expression8 expression = doc_of_expression_desc8 expression.pexp_desc
and doc_of_expression9 expression =
  doc_of_expression_desc9 expression.pexp_desc
and doc_of_expression10 expression =
  doc_of_expression_desc10 expression.pexp_desc
and doc_of_expression11 expression =
  doc_of_expression_desc11 expression.pexp_desc
and doc_of_expression12 expression =
  doc_of_expression_desc12 expression.pexp_desc

and doc_of_expression_desc0 expression_desc =
  match expression_desc with
    | Pexp_when (_, _) ->
	assert false

    | Pexp_sequence (_, _) ->
	let rec f b expr_desc =
	  match expr_desc with
	    | Pexp_sequence (e1, e2) -> f false e1.pexp_desc @ f b e2.pexp_desc
	    | _ ->
		if b then [ doc_of_expression_desc0 expr_desc ]
		else [ HBox [ doc_of_expression_desc0 expr_desc ; Char ';' ] ]
	in
	  HVBox (0, f true expression_desc)

    | _ ->
	doc_of_expression_desc1 expression_desc

and doc_of_expression_desc1 expression_desc =
  match expression_desc with
    | Pexp_let (rec_flag, pat_exprs, expr) ->
	let ofs = match expr.pexp_desc with Pexp_let (_, _, _) -> 0 | _ -> 2 in
	let h =
	  Box (0, [ doc_of_let_bindings false rec_flag pat_exprs ;
		    String "in" ])
	in
	  Box (ofs, [ h ; doc_of_expression0 expr ])

    | Pexp_ifthenelse (tst, thn, None) ->
	let tst_box = Box (2, [ String "if" ; doc_of_expression0 tst ]) in
	let thn_box = Box (0, [ tst_box ; String "then" ]) in
	  Box (2, [ thn_box ; doc_of_expression2 thn ])

    | Pexp_ifthenelse (tst, thn, Some els) ->
	let tst_box = Box (2, [ String "if" ; doc_of_expression0 tst ]) in
	let thn_box = Box (0, [ tst_box ; String "then" ]) in
	let ifthn_box = Box (2, [ thn_box ; doc_of_expression2 thn ]) in
	let els_box = Box (0, [ ifthn_box ; String "else" ]) in
	  Box (2, [ els_box ; doc_of_expression1 els ])

    | _ ->
	doc_of_expression_desc2 expression_desc

and doc_of_expression_desc2 expression_desc =
  match expression_desc with
    | Pexp_variant (label, None) ->
	HBox [ Char '`' ; Cut ; String label ]

    | Pexp_variant (label, Some expr) ->
	Box (2, [ HBox [ Char '`' ; Cut ; String label ] ;
		  doc_of_expression12 expr ])

    | Pexp_setfield (e1, ident, e2) ->
	Box (2, [ HBox [ doc_of_expression12 e1 ; Cut ; Char '.' ; Cut ;
			 doc_of_longident ident ] ;
		  String "<-" ; doc_of_expression0 e2 ])

    | Pexp_send (expr, meth) ->
	Box (2, [ HBox [ doc_of_expression12 expr ; Cut ; Char '#' ] ;
		  Cut ; String meth ])

    | Pexp_new ident ->
	Box (2, [ String "new" ; doc_of_longident ident ])

    | Pexp_setinstvar (ident, expr) ->
	Box (2, [ HBox [ String ident ; String "<-" ] ;
		  doc_of_expression1 expr ])

    | Pexp_override ident_exprs ->
	let g (ident, expr) =
	  Box (2, [ HBox [ String ident ; Char '=' ] ;
		    doc_of_expression2 expr ])
	in
	let rec f ident_exprs =
	  match ident_exprs with
	    | [] -> assert false
	    | [ ident_expr ] -> [ g ident_expr ; String ">}" ]
	    | ident_expr :: rest -> g ident_expr :: Char ';' :: f rest
	in
	  Box (2, String "{<" :: f ident_exprs)

    | Pexp_letmodule (name, modexpr, expr) ->
	Box (2, [ HBox [ String "let" ; String "module" ; String name ;
			 Char '=' ] ;
		  doc_of_module_expr modexpr ; String "in" ;
		  doc_of_expression0 expr ])

    | Pexp_assert expr ->
	Box (2, [ String "assert" ; doc_of_expression12 expr ])

    | Pexp_assertfalse ->
	HBox [ String "assert" ; String "false" ]

    | Pexp_lazy expr ->
	Box (2, [ String "lazy" ; doc_of_expression12 expr ])

    | Pexp_poly (expr, None) ->
	Box (2, [ Char '=' ; doc_of_expression2 expr ])

    | Pexp_poly (expr, Some core_type) ->
	Box (2, [ Char ':' ; doc_of_core_type core_type ; Char '=' ;
		  doc_of_expression2 expr ])

    | Pexp_newtype (name, expr) ->
	Box (2, [ parenthesis (HBox [ String "type" ; String name ]) ;
		  doc_of_expression2 expr ])

    | Pexp_pack (modexpr, packty) ->
	parenthesis (Box (2, [ String "module" ; doc_of_module_expr modexpr ;
			       Char ':' ; doc_of_package_type packty ]))

    | Pexp_open (ident, expr) ->
	Box (2, [ HBox [ String "let" ; String "open" ; doc_of_longident ident ;
			 String "in" ] ; doc_of_expression0 expr ])

    | _ ->
	doc_of_expression_desc3 expression_desc

and doc_of_expression_descX
    left right next operators starts except expression_desc =
  match expression_desc with
    | Pexp_apply ({ pexp_desc = Pexp_ident (Lident ident) ; pexp_loc = _ },
		  [ ident_expr1 ; ident_expr2 ]) when
	(List.mem ident operators || (ident <> "" && List.mem ident.[0] starts))
	&& not (List.mem ident except) ->
	Box (2, [ doc_of_argument left ident_expr1 ; String ident ;
		  doc_of_argument right ident_expr2 ])

    | _ ->
	next expression_desc

and doc_of_expression_desc3 expression_desc =
  doc_of_expression_descX doc_of_expression4 doc_of_expression3
    doc_of_expression_desc4 [ "||" ; "or" ] [] [] expression_desc

and doc_of_expression_desc4 expression_desc =
  doc_of_expression_descX doc_of_expression5 doc_of_expression4
    doc_of_expression_desc5 [ "&&" ] [] [] expression_desc

and doc_of_expression_desc5 expression_desc =
  doc_of_expression_descX doc_of_expression5 doc_of_expression6
    doc_of_expression_desc6 [ "=" ; "<" ; ">" ; "!=" ; "|" ; "&" ; "$" ]
    [ '=' ; '<' ; '>' ; '!' ; '|' ; '&' ; '$' ] [] expression_desc

and doc_of_expression_desc6 expression_desc =
  doc_of_expression_descX doc_of_expression7 doc_of_expression6
    doc_of_expression_desc7 [ "@" ; "^" ] [ '@' ; '^' ] [] expression_desc

and doc_of_expression_desc7 expression_desc =
  match expression_desc with
    | Pexp_construct (Lident "::", _, false) ->
	doc_of_list_construct false expression_desc
    | _ ->
	doc_of_expression_desc8 expression_desc

and doc_of_expression_desc8 expression_desc =
  doc_of_expression_descX doc_of_expression8 doc_of_expression9
    doc_of_expression_desc9 [ "+" ; "-" ; "+." ; "-." ] [ '+' ; '-' ] []
    expression_desc

and doc_of_expression_desc9 expression_desc =
  doc_of_expression_descX doc_of_expression9 doc_of_expression10
    doc_of_expression_desc10
    [ "*" ; "*." ; "/" ; "/." ; "%" ; "%." ; "mod" ; "lor" ; "land" ; "lor" ;
      "lxor" ] [ '*' ; '/' ; '%' ] [ "**" ] expression_desc

and doc_of_expression_desc10 expression_desc =
  doc_of_expression_descX doc_of_expression11 doc_of_expression10
    doc_of_expression_desc11
    [ "lsl" ; "lsr" ; "asr" ; "**" ] [] [] expression_desc

and doc_of_expression_desc11 expression_desc =
  match expression_desc with
    | Pexp_apply ({ pexp_desc = Pexp_ident (Lident ":=") ; pexp_loc = _ },
		  [ ident_expr1 ; ident_expr2 ]) ->
	Box (2, [ doc_of_argument doc_of_expression12 ident_expr1 ;
		  String ":=" ;
		  doc_of_argument doc_of_expression0 ident_expr2 ])

    | Pexp_apply ({ pexp_desc = Pexp_ident (Lident "!") ; pexp_loc = _ },
		  [ ("", expr) ]) ->
	HBox [ Char '!' ; Cut ; doc_of_expression11 expr ]

    | Pexp_apply ({ pexp_desc = Pexp_ident (Lident "~-") ; pexp_loc = _ },
		  [ ("", expr) ]) ->
	HBox [ String "~-" ; Cut ; doc_of_expression11 expr ]

    | Pexp_apply ({ pexp_desc = Pexp_ident (Lident ident) ; pexp_loc = _ },
		  [ _ ; _ ]) when is_operator ident ->
	parenthesis (doc_of_expression_desc3 expression_desc)

    | Pexp_apply (expr, ident_exprs) ->
	doc_of_apply (doc_of_expression12 expr) ident_exprs

    | Pexp_construct (Lident "[]", None, false) ->
	String "[]"

    | Pexp_construct (Lident "()", None, false) ->
	String "()"

    | Pexp_construct (Lident "true", None, false) ->
	String "true"

    | Pexp_construct (Lident "false", None, false) ->
	String "false"

    | Pexp_construct (Lident "::", _, false) ->
	doc_of_expression_desc3 expression_desc

    | Pexp_construct (ident, None, false) ->
	doc_of_longident ident

    | Pexp_construct (ident, Some expr, false) ->
	HBox ([ doc_of_longident ident ; doc_of_expression12 expr ])

    | Pexp_construct (_, _, true) ->
	assert false

    | _ ->
	doc_of_expression_desc12 expression_desc

and doc_of_expression_desc12 expression_desc =
  match expression_desc with
    | Pexp_ident ident ->
	doc_of_longident ident

    | Pexp_constant cst ->
	doc_of_constant cst

    | Pexp_tuple exprs ->
	let rec f exprs =
	  match exprs with
	    | [] -> assert false
	    | [ last ] -> [ doc_of_expression3 last ]
	    | expr :: rest ->
		HBox [ doc_of_expression3 expr ; Cut ; Char ',' ] :: f rest
	in
	  parenthesis (Box (0, f exprs))

    | Pexp_record (ident_exprs, opt_expr) ->
	let g (ident, expr) =
	  Box (2, [ HBox [ doc_of_longident ident ; Char '=' ] ;
		    doc_of_expression1 expr ])
	in
	let rec f ident_exprs =
	  match ident_exprs with
	    | [] -> assert false
	    | [ ident_expr ] ->
		[ g ident_expr ]
	    | ident_expr :: rest ->
		HBox [ g ident_expr ; Char ';' ] :: f rest
	in
	  begin match opt_expr with
	    | None ->
		HBox [ Box (2, Char '{' :: f ident_exprs) ; Char '}' ]
	    | Some expr ->
		HBox [ Box (2, [ Char '{' ; doc_of_expression12 expr ;
				 String "with" ; Box (0, f ident_exprs) ]) ;
		       Char '}' ]
	  end

    | Pexp_array exprs ->
	let rec f exprs =
	  match exprs with
	    | [] -> [ String "|]" ]
	    | [ last ] -> [ doc_of_expression1 last ; String "|]" ]
	    | expr :: rest -> 
		HBox [ doc_of_expression1 expr ; Char ';' ] :: f rest
	in
	  Box (2, String "[|" :: f exprs)

    | Pexp_function ("", None, [ ({ ppat_desc = Ppat_var ident ; ppat_loc = _ },
				  { pexp_desc = expr ; pexp_loc = _ }) ]) ->
	let rec grep_params params expr = match expr with
	  | Pexp_function ("", None,
			   [ ({ ppat_desc = Ppat_var ident ; ppat_loc = _ },
			      sub_expr) ]) ->
	      grep_params (String ident :: params) sub_expr.pexp_desc
	  | _ ->
	      (params, expr)
	in
	let (params, body) = grep_params [ String ident ] expr in
	  Box (0, [ Box (2, [ String "begin";
			      HBox (String "fun" :: List.rev params @
				      [ String "->" ]);
			      doc_of_expression_desc0 body ]);
		    String "end" ])

    | Pexp_function ("", None, pat_exprs) ->
	doc_of_function_patterns pat_exprs

    | Pexp_function (ident, None,
		     [ ({ ppat_desc = pat ; ppat_loc = _ }, expr) ]) ->
	  let b =
	    if pat = Ppat_var ident then
	      if ident <> "" && ident.[0] = '?' then String ident
	      else HBox [ Char '~' ; Cut ; String ident ]
	    else
	      if ident <> "" && ident.[0] = '?' then
		HBox [ String ident ; Cut ; Char ':' ; Cut ;
		       doc_of_pattern_desc3 pat ]
	      else
		HBox [ Char '~' ; Cut ; String ident ; Cut ; Char ':' ; Cut ;
		       doc_of_pattern_desc3 pat ]
	  in
	    Box (0, [ Box (2, [ String "begin" ; String "fun" ;
				Box (0, [ b ; String "->" ]) ;
				doc_of_expression expr ]) ;
		      String "end" ])

    | Pexp_function (ident, Some default, [ (_, expr) ]) ->
	assert (ident <> "" && ident.[0] = '?');
	let ident = String.sub ident 1 (String.length ident - 1) in
	let b = HBox [ String ident ; Char '=' ; doc_of_expression default ] in
	let b = HBox [ Char '?' ; Cut ; parenthesis b ] in
	let b = Box (0, [ b ; String "->" ]) in
	  Box (0, [ Box (2, [ String "begin" ; String "fun" ; b ;
			      doc_of_expression expr ]) ;
		    String "end" ])

    | Pexp_function (_, _, _ :: _) ->
	assert false

    | Pexp_match (expr, pat_exprs) ->
	let match_box =
	  Box (2, [ String "begin" ; String "match" ; doc_of_expression0 expr ])
	in
	let match_with_box = Box (0, [ match_box ; String "with" ]) in
	  begin match pat_exprs with
	    | [ _ ] ->
		Box (0, [ Box (2, [ match_with_box ;
				    doc_of_patterns pat_exprs ]) ;
			  String "end" ])
	    | _ ->
		VBox (0, [ match_with_box ; doc_of_patterns pat_exprs ;
			   String "end" ])
	  end

    | Pexp_try (expr, pat_exprs) ->
	let try_box =
	  Box (2, [ String "begin" ; String "try" ; doc_of_expression0 expr ])
	in
	let try_with_box = Box (0, [ try_box ; String "with" ]) in
	  begin match pat_exprs with
	    | [ _ ] ->
		Box (0, [ Box (2, [ try_with_box ; doc_of_patterns pat_exprs ]);
			  String "end" ])
	    | _ ->
		VBox (0, [ try_with_box ; doc_of_patterns pat_exprs ;
			   String "end" ])
	  end

    | Pexp_while (tst, body) ->
	Box (0, [ Box (2, [ HBox [ String "while" ; doc_of_expression0 tst ;
				 String "do" ] ;
			    doc_of_expression0 body ]) ;
		  String "done" ])

    | Pexp_for (v, frm, too, direct_flag, body) ->
	Box (0, [ Box (2, [ HBox [ String "for" ; String v ; Char '=' ;
				  doc_of_expression0 frm ;
				  doc_of_direction_flag direct_flag ;
				  doc_of_expression0 too ;
				  String "do" ] ;
			    doc_of_expression0 body ]);
		  String "done" ])

    | Pexp_object cs ->
	Box (0, [ doc_of_class_structure cs ; String "end" ])

    | Pexp_constraint (expr, Some core_type, None) ->
	parenthesis (Box (2, [ doc_of_expression0 expr ; Char ':' ;
			       doc_of_core_type core_type ]))

    | Pexp_constraint (expr, None, Some core_type) ->
	parenthesis (Box (2, [ doc_of_expression0 expr ; String ":>" ;
			       doc_of_core_type core_type ]))

    | Pexp_constraint (expr, Some core_type1, Some core_type2) ->
	parenthesis (Box (2, [ doc_of_expression0 expr ; Char ':' ;
			       doc_of_core_type core_type1 ; String ":>" ;
			       doc_of_core_type core_type2 ]))

    | Pexp_constraint (_, None, None) ->
	assert false

    | Pexp_field (expr, ident) ->
	HBox [ doc_of_expression12 expr ; Cut ; Char '.' ; Cut ;
	       doc_of_longident ident ]

    | Pexp_construct (Lident "[]", None, false) ->
	String "[]"

    | Pexp_construct (Lident "()", None, false) ->
	String "()"

    | Pexp_construct (Lident "true", None, false) ->
	String "true"

    | Pexp_construct (Lident "false", None, false) ->
	String "false"

    | Pexp_construct (Lident "::", _, false) ->
	doc_of_list_construct true expression_desc

    | Pexp_construct (ident, None, false) ->
	doc_of_longident ident

    | Pexp_apply ({ pexp_desc = Pexp_ident (Lident "!") ; pexp_loc = _ },
		  [ ("", expr) ]) ->
	HBox [ Char '!' ; Cut ; doc_of_expression11 expr ]

    | Pexp_apply ({ pexp_desc = Pexp_ident (Lident "~-") ; pexp_loc = _ },
		  [ ("", expr) ]) ->
	HBox [ String "~-" ; Cut ; doc_of_expression11 expr ]

    | _ ->
	parenthesis (doc_of_expression_desc0 expression_desc)

(* Type declarations *)

and doc_of_type_kind type_kind =
  match type_kind with
    | Ptype_abstract -> assert false
    | Ptype_variant ident_core_typess ->
	let rec h core_types =
	  match core_types with
	    | [] ->
		assert false
	    | [ core_type ] ->
		[ doc_of_core_type2 core_type ]
	    | core_type :: rest ->
		doc_of_core_type2 core_type :: Char '*' :: h rest
	in
	let g (ident, core_types, _) =
	  match core_types with
	    | [] ->
		String ident
	    | _ ->
		Box (2, [ HBox [ String ident ; String "of" ] ;
			  Box (0, h core_types) ])
	in
	let rec f ident_core_typess =
	  match ident_core_typess with
	    | [] ->
		assert false
	    | [ ident_core_types ] ->
		[ g ident_core_types ]
	    | ident_core_types :: rest ->
		g ident_core_types :: Char '|' :: f rest
	in
	  Box (0, f ident_core_typess)
    | Ptype_record fields ->
	let g (ident, mut_flag, core_type, _) =
	  match mut_flag with
	    | Mutable ->
		Box (2, [ HBox [ String "mutable" ; String ident ;
				 Char ':' ] ; doc_of_core_type core_type ])
	    | Immutable ->
		Box (2, [ HBox [ String ident ; Char ':' ] ;
			  doc_of_core_type core_type ])
	in
	let rec f fields =
	  match fields with
	    | [] ->
		assert false
	    | [ field ] ->
		[ g field ]
	    | field :: rest ->
		HBox [ g field ; Char ';' ] :: f rest
	in
	  HBox [ Box (2, Char '{' :: f fields) ; Char '}' ]
	

(* Type expressions for the class language *)

and doc_of_class_type class_type =
  doc_of_class_type_desc class_type.pcty_desc

and doc_of_class_type_desc class_type_desc =
  match class_type_desc with
    | Pcty_constr (ident, core_types) ->
	let rec g core_types =
	  match core_types with
	    | [] ->
		assert false
	    | [ last ] ->
		[ doc_of_core_type last ]
	    | core_type :: rest ->
		HBox [ doc_of_core_type core_type ; Cut ; Char ',' ] :: g rest
	in
	let f core_types = Box (2, g core_types) in
	  Box (0, [ Box (2, [ Char '[' ; f core_types ]) ;
		    Char ']' ;
		    doc_of_longident ident ])

    | Pcty_signature cs ->
	Box (0, [ Box (2, [ String "object" ; doc_of_class_signature cs ]) ;
		  String "end" ])

    | Pcty_fun (ident, core_type, class_type) ->
	Box (2, [ String ident ; Char ':' ; doc_of_core_type1 core_type ;
		  String "->" ; doc_of_class_type class_type ])

and doc_of_class_signature (core_type, ctf) =
  Box (2, parenthesis (doc_of_core_type core_type) ::
	 List.map doc_of_class_type_field ctf)
    
and doc_of_class_type_field class_type_field =
  match class_type_field with
    | Pctf_inher ct ->
	Box (2, [ String "inherit" ; doc_of_class_type ct ])

    | Pctf_val (ident, mut_flag, virt_flag, core_type, _) ->
	Box (2, [ String "val" ; doc_of_mutable_flag mut_flag ;
		  doc_of_virtual_flag virt_flag ; String ident ;
		  Char ':' ; doc_of_core_type core_type ])

    | Pctf_virt (ident, priv_flag, core_type, _) ->
	Box (2, [ String "method" ; doc_of_private_flag priv_flag ;
		  String "virtual" ; String ident ; Char ':' ;
		  doc_of_core_type core_type ])

    | Pctf_meth (ident, priv_flag, core_type, _) ->
	Box (2, [ String "method" ; doc_of_private_flag priv_flag ;
		  String ident ; Char ':' ; doc_of_core_type core_type ])

    | Pctf_cstr (core_type1, core_type2, _) ->
	Box (2, [ String "constraint" ; doc_of_core_type core_type1 ; Char '=' ;
		  doc_of_core_type core_type2 ])

and doc_of_class_description class_description =
  ignore class_description;
  failwith "doc_of_class_description not yet implemented"

and doc_of_class_type_declaration class_type_declaration =
  ignore class_type_declaration;
  failwith "doc_of_class_type_declaration not yet implemented"

(* Value expressions for the class language *)

and doc_of_class_expr class_expr =
  doc_of_class_expr_desc class_expr.pcl_desc

and doc_of_class_expr_desc class_expr_desc =
  match class_expr_desc with
    | Pcl_constr (ident, []) ->
	doc_of_longident ident

    | Pcl_constr (ident, core_types) ->
	let rec f core_types =
	  match core_types with
	    | [] -> assert false
	    | [ last ] ->
		[ HBox [ doc_of_core_type last ; Char ']' ] ;
		  doc_of_longident ident ]
	    | core_type :: rest ->
		HBox [ doc_of_core_type core_type ; Cut ; Char ',' ] :: f rest
	in
	  Box (2, Char '[' :: f core_types)

    | Pcl_structure cs ->
	doc_of_class_structure cs

    | Pcl_fun ("", None, pat, ce) ->
	Box (2, [ HBox [ String "fun" ; doc_of_pattern pat ; String "->" ] ;
		  doc_of_class_expr ce ])

    | Pcl_fun (lab, None, _pat, ce) ->
	Box (2, [ HBox [ String "fun" ; Char '~' ; Cut ; String lab ; Cut ;
			 String "->" ]; doc_of_class_expr ce ])

    | Pcl_fun (lab, Some e, _pat, ce) ->
	Box (2, [ HBox [ String "fun" ; String "?(" ; String lab ; Cut ;
			 String "=" ; doc_of_expression e ; Cut ; Char ')' ;
			 String "->" ] ; doc_of_class_expr ce ])

    | Pcl_apply (class_expr, ident_exprs) ->
	doc_of_apply (doc_of_class_expr class_expr) ident_exprs

    | Pcl_let (rec_flag, pat_exprs, class_expr) ->
	let ofs = match class_expr.pcl_desc with Pcl_let(_,_,_) -> 0 | _ -> 2 in
	let h =
	  Box (0, [ doc_of_let_bindings true rec_flag pat_exprs ; String "in" ])
	in
	  Box (ofs, [ h ; doc_of_class_expr class_expr ])

    | Pcl_constraint (ce, ct) ->
	parenthesis (Box (2, [ HBox [ doc_of_class_expr ce ; Char ':' ] ;
			       doc_of_class_type ct ]))

and doc_of_class_structure (pat, cfs) =
  match pat.ppat_desc with
    | Ppat_any ->
	VBox (0, [ VBox (2, [ String "object" ;
			      VBox (0, List.map doc_of_class_field cfs) ]) ;
		   String "end" ])

    | _ ->
	VBox (0, [ VBox (2, [ HBox [ String "object" ;
				     parenthesis (doc_of_pattern pat) ] ;
			      VBox (0, List.map doc_of_class_field cfs) ]) ;
		   String "end" ])

and doc_of_class_field class_field =
  match class_field with
    | Pcf_inher (over_flag, ce, None) ->
	Box (2, [ String "inherit" ; doc_of_override_flag over_flag ;
		  doc_of_class_expr ce ])

    | Pcf_inher (over_flag, ce, Some ident) ->
	Box (2, [ String "inherit" ; doc_of_override_flag over_flag ;
		  doc_of_class_expr ce ; String "as" ; String ident ])

    | Pcf_valvirt (ident, mut_flag, core_type, _) ->
	Box (2, [ String "val" ; doc_of_mutable_flag mut_flag ;
		  String "virtual" ; String ident ; Char ':' ;
		  doc_of_core_type core_type ])

    | Pcf_val (ident, Immutable, Fresh, expr, _) ->
	Box (2, [ String "val" ; String ident ;
		  Char '=' ; doc_of_expression expr ])

    | Pcf_val (ident, mut_flag, over_flag, expr, _) ->
	Box (2, [ String "val" ; doc_of_override_flag over_flag ;
		  doc_of_mutable_flag mut_flag ; String ident ;
		  Char '=' ; doc_of_expression expr ])

    | Pcf_virt (ident, priv_flag, core_type, _) ->
	Box (2, [ String "method" ; doc_of_private_flag priv_flag ;
		  String "virtual" ; String ident ; Char ':' ;
		  doc_of_core_type core_type ])

    | Pcf_meth (ident, Public, Fresh, expr, _) ->
	Box (2, [ String "method" ; String ident ; doc_of_expression expr ])

    | Pcf_meth (ident, priv_flag, over_flag, expr, _) ->
	Box (2, [ String "method" ; doc_of_override_flag over_flag ;
		  doc_of_private_flag priv_flag ; String ident ;
		  doc_of_expression expr ])

    | Pcf_cstr (core_type1, core_type2, _) ->
	Box (2, [ String "constraint" ; doc_of_core_type core_type1 ; Char '=' ;
		  doc_of_core_type core_type2 ])

    | Pcf_let (_, _, _) ->
	assert false

    | Pcf_init expr ->
	Box (2, [ String "initializer" ; doc_of_expression expr ])

and doc_of_class_declaration keyword {
  pci_virt = virt_flag;
  pci_params = (params, _);
  pci_name = name;
  pci_expr = class_expr;
  pci_variance = variances;
  pci_loc = _;
} =
  match virt_flag with
    | Virtual -> 
	VBox (2, [ HBox [ String keyword ; String "virtual" ; Space ;
			 doc_of_parameters_variances false params variances  ;
			 String name ; Char '=' ] ;
		  doc_of_class_expr class_expr ])

    | Concrete ->
	VBox (2, [ HBox [ String keyword ; Space ;
			 doc_of_parameters_variances false params variances  ;
			 String name ; Char '=' ] ;
		  doc_of_class_expr class_expr ])

(* Type expressions for the module language *)

and doc_of_module_type module_type =
  doc_of_module_type_desc module_type.pmty_desc

and doc_of_module_type_desc module_type_desc =
  match module_type_desc with
    | Pmty_ident ident ->
	doc_of_longident ident

    | Pmty_signature sis ->
	Box (0, [ Box (2, String "sig" :: List.map doc_of_signature_item sis) ;
		  String "end" ])

    | Pmty_functor (ident, mt1, mt2) ->
	Box (2, [ String "functor" ;
		  parenthesis (HBox [ String ident ; Char ':' ;
				      doc_of_module_type mt1 ]) ;
		  String "->" ; doc_of_module_type mt2 ])

    | Pmty_with (mt, idcs) ->
	let rec f idcs =
	  match idcs with
	    | [] -> assert false
	    | [ last ] -> [ doc_of_ident_with_constraint last ]
	    | idc :: rest ->
		doc_of_ident_with_constraint idc :: String "and" :: f rest
	in
	  Box (2, doc_of_module_type mt :: String "with" :: f idcs)

    | Pmty_typeof me ->
	Box (2, [ String "module" ; String "type" ; String "of" ;
		  doc_of_module_expr me ])

and doc_of_signature_item signature_item =
  doc_of_signature_item_desc signature_item.psig_desc

and doc_of_signature_item_desc signature_item_desc =
  match signature_item_desc with
    | Psig_value (ident, { pval_type = core_type ; pval_prim = []}) ->
	Box (0, [ Box (2, [ HBox [ String "val" ; String ident ; Char ':' ] ;
			    doc_of_core_type core_type ]) ;
		  String ";;" ])

    | Psig_value (ident, vd) ->
	doc_of_external ident vd

    | Psig_type labeltds ->
	doc_of_type labeltds

    | Psig_exception (ident, core_types) ->
	doc_of_exception ident core_types

    | Psig_module (ident, mt) ->
	Box (0, [ Box (2, [ HBox [ String "module" ; String ident ; Char ':' ] ;
			    doc_of_module_type mt ]) ;
		  String ";;" ])

    | Psig_recmodule mts ->
	let g (ident, mt) =
	  Box (0, [ String ident ; Char ':' ; doc_of_module_type mt ])
	in
	let rec f mts =
	  match mts with
	    | [] -> assert false
	    | [ last ] -> [ g last ]
	    | mt :: rest -> g mt :: String "and" :: f rest
	in
	  Box (0, [ Box (2, HBox [ String "module" ; String "rec" ] :: f mts) ;
		    String ";;" ])

    | Psig_modtype (ident, Pmodtype_abstract) ->
	HBox [ String "module" ; String "type" ; String ident ; String ";;" ]

    | Psig_modtype (ident, Pmodtype_manifest mt) ->
	Box (0, [ Box (2, [ HBox [ String "module" ; String "type" ;
				   String ident ; Char '=' ] ;
			    doc_of_module_type mt ]);
		  String ";;" ])

    | Psig_open ident ->
	doc_of_open ident

    | Psig_include mt ->
	Box (0, [ Box (2, [ String "include" ; doc_of_module_type mt ]) ;
		  String ";;" ])

    | Psig_class cds ->
	let rec f cds =
	  match cds with
	    | [] -> assert false
	    | [ last ] -> [ doc_of_class_description last ]
	    | cd :: rest ->
		doc_of_class_description cd :: String "and" :: f rest
	in
	  VBox (0, [ VBox (2, String "class" :: f cds) ; String ";;" ])

    | Psig_class_type ctds ->
	doc_of_class_type_decl ctds

(* value expressions for the module language *)

and doc_of_module_expr module_expr =
  doc_of_module_expr_desc module_expr.pmod_desc

and doc_of_module_expr_desc module_expr_desc =
  match module_expr_desc with
    | Pmod_ident ident ->
	doc_of_longident ident

    | Pmod_structure strct ->
	VBox (0, [ VBox (2, [ String "struct" ; doc_of_structure strct ]) ;
		  String "end" ])

    | Pmod_functor (ident, mt, me) ->
	Box (2, [ String "functor" ;
		  parenthesis (HBox [ String ident ; Char ':' ;
				      doc_of_module_type mt ]) ;
		  String "->" ; doc_of_module_expr me ])

    | Pmod_apply (me1, me2) ->
	Box (2, [ doc_of_module_expr me1 ;
		  parenthesis (doc_of_module_expr me2) ])

    | Pmod_constraint (me, mt) ->
	parenthesis (Box (2, [ HBox [ doc_of_module_expr me ; Char ':' ] ;
			       doc_of_module_type mt ]))

    | Pmod_unpack (expr, pt) ->
	parenthesis (Box (2, [ String "val" ; doc_of_expression expr ;
			       Char ':' ; doc_of_package_type pt ]))

and doc_of_structure_item structure_item =
  doc_of_structure_item_desc structure_item.pstr_desc

and doc_of_structure_item_desc structure_item_desc =
  match structure_item_desc with
    | Pstr_eval expr ->
	Box (0, [ doc_of_expression expr ; String ";;" ])

    | Pstr_value (rec_flag, pat_exprs) ->
	Box (0, [ doc_of_let_bindings true rec_flag pat_exprs ; String ";;" ])

    | Pstr_primitive (ident, vd) ->
	doc_of_external ident vd

    | Pstr_type labeltds ->
	doc_of_type labeltds

    | Pstr_exception (ident, core_types) ->
	doc_of_exception ident core_types

    | Pstr_exn_rebind (ident1, ident2) ->
	Box (0, [ Box (2, [ HBox [ String "exception" ; String ident1 ;
				   Char '=' ] ;
			    doc_of_longident ident2 ]) ;
		  String ";;" ])

    | Pstr_module (ident, me) ->
	VBox (0, [ VBox (2, [ HBox [ String "module" ; String ident ;
				     Char '=' ] ;
			    doc_of_module_expr me ]) ;
		  String ";;" ])

    | Pstr_recmodule mods ->
	let g (ident, mt, me) =
	  Box (2, [ String ident ; Char ':' ; doc_of_module_type mt ;
		    Char '=' ; doc_of_module_expr me ])
	in
	let rec f mods =
	  match mods with
	    | [] -> assert false
	    | [ last ] -> [ g last ]
	    | md :: rest -> g md :: String "and" :: f rest
	in
	  Box (0, [ Box (2, HBox [ String "module" ; String "rec" ] :: f mods) ;
		    String ";;" ])

    | Pstr_modtype (ident, mt) ->
	Box (0, [ Box (2, [ HBox [ String "module" ; String "type" ;
				   String ident ; Char '=' ] ;
			    doc_of_module_type mt ]) ;
		  String ";;" ])

    | Pstr_open ident ->
	doc_of_open ident

    | Pstr_class cds ->
	let rec f keyword cds =
	  match cds with
	    | [] -> assert false
	    | [ last ] -> [ doc_of_class_declaration keyword last ]
	    | cd :: rest ->
		doc_of_class_declaration keyword cd :: f "and" rest
	in
	  VBox (0, [ VBox (2, f "class" cds) ; String ";;" ])

    | Pstr_class_type ctds ->
	doc_of_class_type_decl ctds

    | Pstr_include me ->
	Box (0, [ Box (2, [ String "include" ; doc_of_module_expr me ]) ;
		  String ";;" ])

(* Toplevel phrases *)

and doc_of_toplevel_phrase toplevel_phrase =
  match toplevel_phrase with
    | Ptop_def sis ->
	let g si = doc_of_structure_item si in
	let rec f sis =
	  match sis with
	    | [] -> []
	    | si :: rest -> g si :: f rest
	in
	  Box (2, f sis)

    | Ptop_dir (ident, da) ->
	Box (2, [ Char '#' ; String ident ; doc_of_directive_argument da ])

and doc_of_directive_argument directive_argument =
  match directive_argument with
    | Pdir_none -> Cut
    | Pdir_string s -> String s
    | Pdir_int i -> Int i
    | Pdir_ident ident -> doc_of_longident ident
    | Pdir_bool b -> Bool b

(*** Tools ***)

and insert_newlines docs =
  match docs with
    | [ _ ] | [] ->
	docs

    | HBox (String "open" :: _) as doc ::
	((HBox (String "open" :: _) :: _) as rest)

    | (Box (0, Box (2, String "include" :: _) :: _) as doc ::
	 ((Box (0, Box (2, String "include" :: _) :: _) :: _) as rest))

    | (Box (0, Box (2, HBox (String "exception" :: _) :: _) :: _) as doc ::
	 ((Box (0, Box (2, HBox (String "exception" :: _) :: _) :: _) :: _)
	    as rest)) ->
	doc :: insert_newlines rest

    | doc :: rest ->
	doc :: void_box :: insert_newlines rest

and doc_of_toplevel_phrases toplevel_phrases =
  VBox (0, insert_newlines (List.map doc_of_toplevel_phrase toplevel_phrases))

and doc_of_structure structure_items =
  VBox (0, insert_newlines (List.map doc_of_structure_item structure_items))

and doc_of_implementation structure_items =
  VBox (0, insert_newlines (List.map doc_of_structure_item structure_items))

and doc_of_signature signature_items =
  VBox (0, insert_newlines (List.map doc_of_signature_item signature_items))

and doc_of_argument doc_of_expr (ident, expr) =
  if ident = "" then doc_of_expr expr
  else
    let (c, ident) =
      if ident.[0] = '?' then ('?', String.sub ident 1 (String.length ident-1))
      else ('~', ident)
    in
      Box (2, [ HBox [ Char c ; Cut ; String ident ; Cut ; Char ':' ] ;
		Cut ; parenthesis (doc_of_expr expr) ])

and doc_of_apply expr_doc ident_exprs =
  Box (2, expr_doc ::
	 List.map (doc_of_argument doc_of_expression12) ident_exprs)

and doc_of_constraints cstrs =
  let f (cstr1, cstr2, _) =
    Box (2, [ String "constraint" ; doc_of_core_type cstr1 ; Char '=' ;
	      doc_of_core_type cstr2 ])
  in
    Box (2, List.map f cstrs)

and doc_of_core_types core_types =
  let rec f core_types =
    match core_types with
      | [] ->
	  assert false
      | [ last ] ->
	  [ doc_of_core_type last ]
      | core_type :: rest ->
	  doc_of_core_type core_type :: Cut :: Char ',' :: f rest
  in
    match core_types with
      | [] -> Space
      | [ core_type ] -> doc_of_core_type2 core_type
      | _ -> parenthesis (HBox (f core_types))

and doc_of_backquote_labels labels cl =
  let g label = HBox [ Char '`' ; Cut ; String label ] in
  let rec f labels =
    match labels with
      | [] -> [ String cl ]
      | [ last ] -> [ g last ; String cl ]
      | label :: rest -> g label :: f rest
  in
    Box (2, f labels)
      
and doc_of_parameters_variances paren parameters variances =
  let h (lid, var) =
    match var with
      | (false, false) -> HBox [ Char '\'' ; Cut ; String lid ]
      | (true, false) -> HBox [ Char '+' ; Cut ; Char '\'' ; Cut ; String lid ]
      | (false, true) -> HBox [ Char '-' ; Cut ; Char '\'' ; Cut ; String lid ]
      | (true, true) -> assert false
  in
  let rec g ctp =
    match ctp with
      | [] ->
	  assert false
      | [ last ] ->
	  if paren then [ h last ; Cut ; Char ')' ]
	  else [ h last ; Char ']' ]
      | pv :: rest ->
	  HBox [ h pv ; Cut ; Char ',' ] :: g rest
  in
    match List.map2 (fun p v -> (p, v)) parameters variances with
      | [] ->
	  Cut
      | [ uniq ] ->
	  if paren then h uniq
	  else HBox [ Char '[' ; h uniq ; Char ']' ]
      | ctp ->
	  if paren then Box (2, Char '(' :: Cut :: g ctp)
	  else Box (2, Char '[' :: g ctp)

and doc_of_ident_with_constraint (ident, wc) =
  match wc with
    | Pwith_type td ->
	HBox [ String "type" ; Space ;
	       doc_of_parameters_variances true td.ptype_params
		 td.ptype_variance ;
	       doc_of_longident ident ; Char '=' ;
	       doc_of_private_flag td.ptype_private ;
	       doc_of_manifest td.ptype_manifest ;
	       doc_of_constraints td.ptype_cstrs ]

    | Pwith_typesubst td ->
	HBox [ String "type" ; Space ;
	       doc_of_parameters_variances true td.ptype_params
		 td.ptype_variance ;
	       doc_of_longident ident ; String ":=" ;
	       doc_of_manifest td.ptype_manifest ]

    | Pwith_module ident' ->
	HBox [ String "module" ; doc_of_longident ident ; Char '=' ;
	       doc_of_longident ident' ]

    | Pwith_modsubst ident' ->
	HBox [ String "module" ; doc_of_longident ident ; String ":=" ;
	       doc_of_longident ident' ]

and doc_of_class_type_decl ctds =
  let rec f ctds =
    match ctds with
      | [] ->
	  assert false
      | [ last ] ->
	  [ doc_of_class_type_declaration last ]
      | ctd :: rest ->
	  doc_of_class_type_declaration ctd :: String "and" :: f rest
  in
    VBox (0, [ VBox (2, HBox [ String "class" ; String "type" ] :: f ctds) ;
	       String ";;" ])

and doc_of_open ident =
  HBox [ String "open" ; doc_of_longident ident ; String ";;" ]

and doc_of_exception ident core_types =
  if core_types = [] then
    HBox [ String "exception" ; String ident ; String ";;" ]
  else
    let rec f core_types =
      match core_types with
	| [] -> assert false
	| [ last ] -> [ doc_of_core_type2 last ]
	| core_type :: rest -> doc_of_core_type2 core_type :: Char '*' :: f rest
    in
      Box (0, [ Box (2, HBox [ String "exception" ; String ident ;
			       String "of" ] :: f core_types) ;
		String ";;" ])
	
and doc_of_type ident_tds =
  let g intr (ident, td) =
    let params =
      doc_of_parameters_variances true td.ptype_params td.ptype_variance
    in
      match (td.ptype_manifest, td.ptype_kind) with
	| (None, Ptype_abstract) ->
	    let h = HBox [ String intr ; Space ; params ; String ident ] in
	      if td.ptype_cstrs = [] then h
	      else Box (2, [ h ; doc_of_constraints td.ptype_cstrs ])

	| (Some ct, Ptype_abstract) ->
	    let h =
	      HBox [ String intr ; Space ; params ; String ident ; Char '=' ]
	    in
	      if td.ptype_cstrs = [] then
		Box (2, [ h ; doc_of_private_flag td.ptype_private ;
			  doc_of_core_type ct ])
	      else
		Box (2, [ h ; doc_of_private_flag td.ptype_private ;
			  doc_of_core_type ct ;
			  doc_of_constraints td.ptype_cstrs ])

	| (None, type_kind) ->
	    let h =
	      HBox [ String intr ; Space ; params ; String ident ; Char '=' ]
	    in
	      if td.ptype_cstrs = [] then
		Box (2, [ h ; doc_of_private_flag td.ptype_private ;
			  doc_of_type_kind type_kind ])
	      else
		Box (2, [ h ; doc_of_private_flag td.ptype_private ;
			  doc_of_type_kind type_kind ;
			  doc_of_constraints td.ptype_cstrs ])

	| (Some ct, type_kind) ->
	    let h =
	      HBox [ String intr ; Space ; params ; String ident ; Char '=' ]
	    in
	      if td.ptype_cstrs = [] then
		Box (2, [ h ; doc_of_core_type ct ; Char '=' ;
			  doc_of_private_flag td.ptype_private ;
			  doc_of_type_kind type_kind ])
	      else
		Box (2, [ h ; doc_of_core_type ct ; Char '=' ;
			  doc_of_private_flag td.ptype_private ;
			  doc_of_type_kind type_kind ;
			  doc_of_constraints td.ptype_cstrs ])
  in
  let rec f ident_tds =
    match ident_tds with
      | [] ->
	  assert false
      | [ ident_td ] ->
	  [ void_box ; Box (0, [ g "and" ident_td ]) ]
      | ident_td :: rest ->
	  void_box :: g "and" ident_td :: f rest
  in
    match ident_tds with
      | [] ->
	  assert false
      | [ ident_td ] ->
	  HBox [ g "type" ident_td ; String ";;" ]
      | ident_td :: rest ->
	  VBox (0, g "type" ident_td :: f rest @ [ String ";;" ])
	    
and doc_of_external ident { pval_type = core_type ; pval_prim = prims } =
  let f prim = String (sprintf "%S" prim) in
    Box (0, [ Box (2, [ HBox [ String "external" ; String ident ; Char ':' ] ;
			doc_of_core_type core_type ; Char '=' ] @
		     (List.map f prims)) ;
	      String ";;" ])

and doc_of_let_bindings newlines rec_flag pat_exprs =
  let rec g pat expr =
    match expr.pexp_desc with
      | Pexp_function ("", None, [ (pat', expr') ]) ->
	  let (pats, expr'') = g pat' expr' in
	    (doc_of_pattern3 pat :: pats, expr'')
      | _ ->
	  ([ doc_of_pattern3 pat ], doc_of_expression expr)
  in
  let rec f pat_exprs =
    match pat_exprs with
      | [] ->
	  []
      | (pat, expr) :: rest ->
	  let (pats, expr) = g pat expr in
	  let h = HBox [ String "and" ; HBox pats ; Char '=' ] in
	  let b = Box (2, [ h ; expr ]) in
	    if newlines then void_box :: b :: f rest
	    else b :: f rest
  in
    match pat_exprs with
      | [] ->
	  assert false
      | (pat, expr) :: rest ->
	  let (pats, expr) = g pat expr in
	  let h = HBox [ String "let" ; doc_of_rec_flag rec_flag ; HBox pats ;
			 Char '=' ]
	  in
	  let b = Box (2, [ h ; expr ]) in
	    if rest = [] then b else VBox (0, b :: f rest)

and doc_list_of_multiple_patterns pat_exprs =
  let rec f pat_exprs =
    match pat_exprs with
      | [] ->
	  []
      | (pat, expr) :: rest ->
	  match expr.pexp_desc with
	    | Pexp_when (e1, e2) ->
		let h =
		  Box (2, [ HBox [ Char '|' ; doc_of_pattern pat ] ;
			    HBox [ String "when" ; doc_of_expression e1 ;
				   String "->" ] ])
		in
		let b = Box (4, [ h ; doc_of_expression e2 ]) in
		  b :: f rest
	    | _ ->
		let h = HBox [ Char '|' ; doc_of_pattern pat ; String "->" ] in
		let b = Box (4, [ h ; doc_of_expression expr ]) in
		  b :: f rest
  in
    f pat_exprs

and doc_of_patterns pat_exprs =
  match pat_exprs with
    | [] ->
	assert false
    | [ (pat, expr) ] ->
	begin match expr.pexp_desc with
	  | Pexp_when (e1, e2) ->
	      let h =
		Box (2, [ doc_of_pattern pat ;
			  HBox [ String "when" ; doc_of_expression e1 ;
				String "->" ] ])
	      in
		Box (2, [ h ; doc_of_expression e2 ])
	  | _ ->
	      let h = HBox [ doc_of_pattern pat ; String "->" ] in
		Box (2, [ h ; doc_of_expression expr ])
	  end
    | _ ->
	VBox (0, doc_list_of_multiple_patterns pat_exprs)

and doc_of_function_patterns pat_exprs =
  match pat_exprs with
    | [] ->
	assert false
    | [ (pat, expr) ] ->
	begin match expr.pexp_desc with
	  | Pexp_when (e1, e2) ->
	      let h =
		Box (2, [ doc_of_pattern pat ;
			  HBox [ String "when" ; doc_of_expression e1 ;
				 String "->" ] ])
	      in
	      let f = Box (2, [ String "begin" ; String "function" ; h ]) in
	      let b = Box (2, [ f ; doc_of_expression e2 ]) in
		Box (0, [ b ; String "end" ])
	  | _ ->
	      let h = HBox [ doc_of_pattern pat ; String "->" ] in
	      let f = Box (2, [ String "begin" ; String "function" ; h ]) in
	      let b = Box (2, [ f ; doc_of_expression expr ]) in
		Box (0, [ b ; String "end" ])
	end
    | _ ->
	VBox (0, [ VBox (2, HBox [ String "begin" ; String "function" ] ::
			   doc_list_of_multiple_patterns pat_exprs ) ;
		   String "end"])

and doc_of_manifest opt_core_type =
  match opt_core_type with
    | None -> Space
    | Some core_type -> doc_of_core_type core_type

and doc_of_list_construct to_close expression_desc =
  let rec f expr =
    match expr with
      | Pexp_construct (Lident "::",
			Some { pexp_desc = Pexp_tuple [ e1 ; e2 ] ;
			       pexp_loc = _ }, false) ->
	  let (b, tl) = f e2.pexp_desc in
	    (b, e1.pexp_desc :: tl)
      | Pexp_construct (Lident "::",_ , _) ->
	  assert false
      | Pexp_construct (Lident "[]", None, false) ->
	  (true, [])
      | _ ->
	  (false, [ expr ])
  in
  let rec g exprs =
    match exprs with
      | [] ->
	  assert false
      | [ expr ] ->
	  [ doc_of_expression_desc2 expr ]
      | expr :: rest ->
	  doc_of_expression_desc2 expr :: String "::" :: g rest
  in
  let rec h exprs =
    match exprs with
      | [] ->
	  assert false
      | [ expr ] ->
	  [ doc_of_expression_desc2 expr ]
      | expr :: rest ->
	  HBox [ doc_of_expression_desc2 expr ; Char ';' ] :: h rest
  in
  let i exprs =
    match exprs with
      | [] ->
	  String "[]"
      | [ expr ] ->
	  HBox [ Char '[' ; doc_of_expression_desc2 expr ; Char ']' ]
      | expr :: rest ->
	  HOVBox (0, [ HOVBox (2, HBox [ Char '[' ;
					 doc_of_expression_desc2 expr ;
					 Char ';' ]
				 :: h rest) ;
		    Char ']' ])
  in
  let (closed, exprs) = f expression_desc in
    if closed then i exprs
    else if to_close then parenthesis (Box (2, g exprs))
    else Box (2, g exprs)
